home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / comp0_89.lha / Feel / Boot / Compiler / peep-macs.em < prev    next >
Lisp/Scheme  |  1993-07-12  |  3KB  |  116 lines
  1. ;; Eulisp Module
  2. ;; Author: pab
  3. ;; File: comp-rules.em
  4. ;; Date: Wed Apr  1 00:50:29 1992
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;   Rule compiler for peephole optimizer
  9.  
  10. (defmodule peep-macs
  11.   (standard0
  12.    list-fns
  13.    
  14.    )
  15.   ()
  16.        
  17.   (defun preprocess-instruct (args)
  18.     (if (= (length args) 3)
  19.     `(if (not (match-instruct ',(car args) i))
  20.          (cons nil nil)
  21.        (let ,(make-bindings (cadr args))
  22.          ,(preprocess-rules (caddr args))))
  23.       (error "Instruct error.." <clock-tick> 'error-value args)))
  24.  
  25.   (defun make-bindings (lst)
  26.     (labels ((binder (names n)
  27.              (if (null names) nil
  28.                (cons (list (car names) `(i-arg-ref i ,n))
  29.                  (binder (cdr names) (+ n 1))))))
  30.         (binder lst 0)))
  31.  
  32.   (defun preprocess-attributes (args)
  33.     `(if ,(mk-attrib-test (car args))
  34.      (let ((,(cadr args) i))
  35.        ,(preprocess-rules (caddr args)))
  36.        (cons nil nil)))
  37.  
  38.   (defun mk-attrib-test (args)
  39.     `(let ((@-info-@ (i-info i)))
  40.        (and ,@(mapcar (lambda (test) 
  41.             `(equal (slot-value @-info-@ ',(car test))
  42.                 ,(cadr test)))
  43.               args))))
  44.     
  45.  
  46.   (defun preprocess-test (args)
  47.     `(if ,(preprocess-test-conditions (car args))
  48.      ,(preprocess-rules (cadr args))
  49.        (cons nil nil)))
  50.   
  51.  
  52.   (defun preprocess-test-conditions (tests)
  53.     (cons 'and tests))
  54.               
  55.   (defun preprocess-next (args)
  56.     `(cons nil 
  57.        (lambda (i) 
  58.          ,(preprocess-rules (car args)))))
  59.  
  60.   (defun preprocess-one-of (args)
  61.     (fold (lambda (preproc lst)
  62.         `(combine-results ,preproc ,lst))
  63.       (mapcar (lambda (x) 
  64.             (preprocess-rules x))
  65.           args)
  66.       '(cons nil nil)))
  67.  
  68.   (defun preprocess-do-rules (args)
  69.     `(,(car args) i))
  70.  
  71.   (defun preprocess-output (args)
  72.     `(cons (cons (list ,@(mapcar 
  73.               (lambda (text) 
  74.                 (if (atom text)
  75.                 text
  76.                   `(,(car text) 
  77.                 (list ,@(cdr text)))))
  78.               args))
  79.          nil)
  80.        nil))
  81.  
  82.   (defconstant find-preproc (mk-finder))
  83.   (progn ((setter find-preproc) 'output  preprocess-output)
  84.      ((setter find-preproc) 'next  preprocess-next)
  85.      ((setter find-preproc) 'instruct  preprocess-instruct)  
  86.      ((setter find-preproc) 'test  preprocess-test)
  87.      ((setter find-preproc) 'attributes  preprocess-attributes)
  88.      ((setter find-preproc) 'one-of  preprocess-one-of)
  89.      ((setter find-preproc) 'do-rules  preprocess-do-rules))
  90.  
  91.   (defun preprocess-rules (rule)
  92.     ((find-preproc (car rule)) (cdr rule)))
  93.   
  94.   (defmacro peephole-matcher (x)
  95.     `(lambda (i)
  96.        ,(preprocess-rules  x)))
  97.  
  98.   (defun combine-results (new-thing rest)
  99.     (cons (append (car new-thing)
  100.           (car rest))
  101.       (if (null (cdr rest))
  102.           (if (null (cdr new-thing))
  103.           nil
  104.         (cdr new-thing))
  105.         (if (null (cdr new-thing))
  106.         (cdr rest)
  107.           (lambda (i)
  108.         (combine-results ((cdr new-thing) i)
  109.                  ((cdr rest) i)))))))
  110.  
  111.  
  112.   (export peephole-matcher  preprocess-rules combine-results)
  113.  
  114.   ;; end module
  115. )
  116.